home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
lsp
/
arraylib.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-04
|
8KB
|
266 lines
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
;;;; arraylib.lsp
;;;;
;;;; array routines
(in-package 'lisp)
(export '(make-array vector
array-element-type array-rank array-dimension
array-dimensions
array-in-bounds-p array-row-major-index
adjustable-array-p
bit sbit
bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor
bit-andc1 bit-andc2 bit-orc1 bit-orc2 bit-not
array-has-fill-pointer-p fill-pointer
vector-push vector-push-extend vector-pop
adjust-array))
(in-package 'system)
(proclaim '(optimize (safety 2) (space 3)))
(defun make-array (dimensions
&key (element-type t)
(initial-element nil initial-element-supplied-p)
(initial-contents nil initial-contents-supplied-p)
adjustable fill-pointer
displaced-to (displaced-index-offset 0)
static)
(when (integerp dimensions) (setq dimensions (list dimensions)))
(cond ((= (length dimensions) 1)
(let ((x (si:make-vector element-type (car dimensions)
adjustable fill-pointer
displaced-to displaced-index-offset
static)))
(when initial-element-supplied-p
(do ((n (car dimensions))
(i 0 (1+ i)))
((>= i n))
(declare (fixnum n i))
(si:aset x i initial-element)))
(when initial-contents-supplied-p
(do ((n (car dimensions))
(i 0 (1+ i)))
((>= i n))
(declare (fixnum n i))
(si:aset x i (elt initial-contents i))))
x))
(t
(let ((x
(apply #'si:make-pure-array
element-type adjustable
displaced-to displaced-index-offset
static
dimensions)))
(when initial-element-supplied-p
(do ((cursor
(make-list (length dimensions)
:initial-element 0)))
(nil)
(aset-by-cursor x initial-element cursor)
(when (increment-cursor cursor dimensions)
(return nil))))
(when initial-contents-supplied-p
(do ((cursor
(make-list (length dimensions)
:initial-element 0)))
(nil)
(aset-by-cursor x
(sequence-cursor initial-contents
cursor)
cursor)
(when (increment-cursor cursor dimensions)
(return nil))))
x))))))))))
(defun increment-cursor (cursor dimensions)
(if (null cursor)
t
(let ((carry (increment-cursor (cdr cursor) (cdr dimensions))))
(if carry
(cond ((>= (the fixnum (1+ (the fixnum (car cursor))))
(the fixnum (car dimensions)))
(rplaca cursor 0)
t)
(t
(rplaca cursor
(the fixnum (1+ (the fixnum (car cursor)))))
nil))
nil))))
(defun sequence-cursor (sequence cursor)
(if (null cursor)
sequence
(sequence-cursor (elt sequence (the fixnum (car cursor)))
(cdr cursor))))
(defun vector (&rest objects)
(make-array (list (length objects))
:element-type t
:initial-contents objects))
(defun array-dimensions (array)
(do ((i (array-rank array))
(d nil))
((= i 0) d)
(setq i (1- i))
(setq d (cons (array-dimension array i) d))))
(defun array-in-bounds-p (array &rest indices &aux (r (array-rank array)))
(when (/= r (length indices))
(error "The rank of the array is ~R,~%~
~7@Tbut ~R ~:*~[indices are~;index is~:;indices are~] ~
supplied."
r (length indices)))
(do ((i 0 (1+ i))
(s indices (cdr s)))
((>= i r) t)
(when (or (< (car s) 0)
(>= (car s) (array-dimension array i)))
(return nil))))
(defun array-row-major-index (array &rest indices)
(do ((i 0 (1+ i))
(j 0 (+ (* j (array-dimension array i)) (car s)))
(s indices (cdr s)))
((null s) j)))
(defun bit (bit-array &rest indices)
(apply #'aref bit-array indices))
(defun sbit (bit-array &rest indices)
(apply #'aref bit-array indices))
(defun bit-and (bit-array1 bit-array2 &optional result-bit-array)
(bit-array-op boole-and bit-array1 bit-array2 result-bit-array))
(defun bit-ior (bit-array1 bit-array2 &optional result-bit-array)
(bit-array-op boole-ior bit-array1 bit-array2 result-bit-array))
(defun bit-xor (bit-array1 bit-array2 &optional result-bit-array)
(bit-array-op boole-xor bit-array1 bit-array2 result-bit-array))
(defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array)
(bit-array-op boole-eqv bit-array1 bit-array2 result-bit-array))
(defun bit-nand (bit-array1 bit-array2 &optional result-bit-array)
(bit-array-op boole-nand bit-array1 bit-array2 result-bit-array))
(defun bit-nor (bit-array1 bit-array2 &optional result-bit-array)
(bit-array-op boole-nor bit-array1 bit-array2 result-bit-array))
(defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array)
(bit-array-op boole-andc1 bit-array1 bit-array2 result-bit-array))
(defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array)
(bit-array-op boole-andc2 bit-array1 bit-array2 result-bit-array))
(defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array)
(bit-array-op boole-orc1 bit-array1 bit-array2 result-bit-array))
(defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array)
(bit-array-op boole-orc2 bit-array1 bit-array2 result-bit-array))
(defun bit-not (bit-array &optional result-bit-array)
(bit-array-op boole-c1 bit-array bit-array result-bit-array))
(defun vector-push (new-element vector)
(let ((fp (fill-pointer vector)))
(declare (fixnum fp))
(cond ((< fp (the fixnum (array-dimension vector 0)))
(si:aset vector fp new-element)
(si:fill-pointer-set vector (the fixnum (1+ fp)))
fp)
(t nil))))
(defun vector-push-extend (new-element vector
&optional (extension (array-dimension vector 0)))
(let ((fp (fill-pointer vector)))
(declare (fixnum fp))
(cond ((< fp (the fixnum (array-dimension vector 0)))
(si:aset vector fp new-element)
(si:fill-pointer-set vector (the fixnum (1+ fp)))
fp)
(t
(adjust-array vector
(list (+ (array-dimension vector 0) extension))
:element-type (array-element-type vector)
:fill-pointer fp)
(si:aset vector fp new-element)
(si:fill-pointer-set vector (the fixnum (1+ fp)))
fp))))
(defun vector-pop (vector)
(let ((fp (fill-pointer vector)))
(declare (fixnum fp))
(when (= fp 0)
(error "The fill pointer of the vector ~S zero." vector))
(si:fill-pointer-set vector (the fixnum (1- fp)))
(aref vector (the fixnum (1- fp)))))
(defun adjust-array (array new-dimensions
&rest r
&key element-type
initial-element
initial-contents
fill-pointer
displaced-to
displaced-index-offset
static)
(declare (ignore element-type
initial-element
initial-contents
fill-pointer
displaced-to
displaced-index-offset
static))
(when (integerp new-dimensions)
(setq new-dimensions (list new-dimensions)))
(let ((element-type (array-element-type array)))
(unless (eq element-type t) (push element-type r)
(push :element-type r)))
(let ((x (apply #'make-array new-dimensions :adjustable t r)))
(do ((cursor (make-list (length new-dimensions) :initial-element 0)))
(nil)
(when (apply #'array-in-bounds-p array cursor)
(aset-by-cursor x
(apply #'aref array cursor)
cursor))
(when (increment-cursor cursor new-dimensions)
(return nil)))
(si:replace-array array x)
))